perm filename TOT.MAS[NET,GUE] blob
sn#003918 filedate 1972-11-02 generic text, type T, neo UTF8
(PROGN (LISPXPRIN1 (QUOTE "FILE CREATED ")
T)
(LISPXPRIN1 (QUOTE " 1-NOV-72 23:24:51")
T)
(LISPXTERPRI T))
(LISPXPRINT (QUOTE TOTALVARS)
T)
(RPAQQ
TOTALVARS
((FNS COLLECT FILEADD UNCOLLECT)
(FNS RECOLLECT RECALL GSET PUTPROP LF LC QUIT GETFILE READDIR)
(VARS (CURRENTFILE NIL)
(MACROFLAG NIL))
(P (SETQ YESFNS USERWORDS))
(P (/SET (QUOTE PRETTYMACROS)
(UNION [QUOTE ((RECORD (L)
(PROP RECORD L)
(P (RECORD L)))
(LMMMAC (L)
(P (FIXMACRO (QUOTE L]
PRETTYMACROS)))
(FNS COUNTDOWN EXPANSION)
(VARS (RECORDFLG NIL)
MACEXPAND)
[P (EDITE MACEXPAND (QUOTE ((COMS (##))
OK]
(FNS PRINTREC PRINTREC1 !RECORD)
(P (/SET (QUOTE NOFNS)
(UNION (QUOTE (FOR IF))
NOFNS))
(/SET (QUOTE QUOTEFNS)
NIL))
(FNS FIXMACRO MACRO ANYTWICE CADRLAST CARLIST)
(FNS RECORD RECDO COMPOSE COMPOSE1 COMPOSE2 COMPOSE3 COMPOSE4
≠CONS ≠REPLACE)
(FNS *FOR +NEXT VARNAME CONDIT SETIT INITL +PV GONEXTN | +TESTSET
NEGATE *IF THENCLAUSE FOR IF)
(LMMMAC IF)
(LMMMAC FOR)))
(DEFINEQ
(COLLECT
[LAMBDA (FILE)
(UNADVISE LOAD)
(UNCOLLECT)
(GETFILE FILE)
[ADVISE (QUOTE DEFINE)
(QUOTE AFTER)
(QUOTE (MAPC !VALUE (FUNCTION (LAMBDA (FN)
(FILEADD FNS FN]
(SETQ CURRENTFILE FILE)
(ADVISE (QUOTE LOAD)
(QUOTE BEFORE)
(QUOTE (UNCOLLECT)))
(ADVISE (QUOTE LOAD)
(QUOTE AFTER)
(QUOTE (RECOLLECT)))
FILE])
(FILEADD
[NLAMBDA (TYPE ITEM)
[COND
((ATOM TYPE)
(SETQ TYPE (LIST TYPE]
(COND
((OR (EQ (CAR (QUOTE CURRENTFILE))
(QUOTE NOBIND))
(NOT CURRENTFILE))
(/SET (QUOTE EXTRAFNS)
(CONS (APPEND TYPE (EVAL ITEM))
EXTRAFNS)))
(T (PROG (TYPEL VARSLIST (CURRENTFILE (GETFILE CURRENTFILE)))
[SETQ VARSLIST (CAR (CADR (GETP CURRENTFILE
(QUOTE FILE]
(OR (AND [NOT (MEMBER TYPE (QUOTE ((RECORD)
(LMMMAC]
(NOT (CDR TYPE))
(SETQ TYPEL (ASSOC (CAR TYPE)
VARSLIST)))
(PROG1 (SETQ TYPEL TYPE)
(/NCONC1 VARSLIST TYPEL)))
(/NCONC1 TYPEL (EVAL ITEM))
(/NCONC1 (GETP CURRENTFILE (QUOTE FILE))
(EVAL ITEM])
(UNCOLLECT
[LAMBDA NIL
(UNADVISE DEFINE)
(PROG1 (/SET (QUOTE LASTCOLLECT)
CURRENTFILE)
(/SET (QUOTE CURRENTFILE)
NIL])
)
(DEFINEQ
(RECOLLECT
[LAMBDA NIL
(READVISE DEFINE)
(/SET (QUOTE CURRENTFILE)
LASTCOLLECT])
(RECALL
[LAMBDA (FN)
(RETEVAL FN (CONS FN (VARIABLES FN])
(GSET
[LAMBDA (X Y)
(FILEADD VARS X)
(/SET X Y])
(PUTPROP
[LAMBDA (NAM IND VAL)
(APPLY (QUOTE FILEADD)
(LIST (LIST (QUOTE PROP)
IND)
(QUOTE NAM)))
(PUT NAM IND VAL])
(LF
[LAMBDA (FILES)
(MAPC FILES (FUNCTION LOAD])
(LC
[LAMBDA (FILES)
(OR FILES (SETQ FILES (READDIR)))
(MAPC FILES (FUNCTION (LAMBDA (FILE)
(LOAD (PACK (LIST FILE ".COM"])
(QUIT
[LAMBDA NIL
(MAKEFILES ' (FAST RC))
(LOGOUT])
(GETFILE
[LAMBDA (FILE)
[COND
(MACROFLAG (SETQ FILE (PACK (LIST FILE "MACROS"]
[COND
((NOT (MEMBER FILE FILELST))
(COND
((INFILEP FILE)
(LOAD FILE))
(T [/PUT FILE (QUOTE FILE)
(LIST (/RPLACA (PACK (LIST FILE "FNS")))
(/RPLACA (PACK (LIST FILE "VARS"))
(COPY (QUOTE ((FNS)
(VARS]
(SAVESET (QUOTE FILELST)
(CONS FILE FILELST]
FILE])
(READDIR
[LAMBDA NIL
(CLEARBUF T T)
(LINBUF NIL)
(SYSBUF NIL)
(PROG (FIL RESLT HELPCLOCK (CNT 20))
(TENEX "DIR *.COM ,
OU D.D;0
")
(INFILE (QUOTE D.D))
(READ (QUOTE D.D))
LP [SETQ FIL (NLSETQ (READ (QUOTE D.D]
(COND
((NOT FIL)
(RETURN RESLT)))
(SETQ FIL (NAMEFIELD (CAR FIL)))
(PRIN1 FIL)
(PRIN1 " ? ")
WT (COND
((MINUSP (SETQ CNT (SUB1 CNT)))
(PRIN1 "...Y")
(GO YEP))
((NOT (READP T))
(DISMISS 500)
(GO WT))
((NOT (EQ (PEEKC T)
(QUOTE Y)))
(GO NOPE)))
YEP (SETQ RESLT (CONS FIL RESLT))
NOPE(CLEARBUF T T)
(TERPRI)
(SETQ CNT 10)
(GO LP])
)
(RPAQ CURRENTFILE NIL)
(RPAQ MACROFLAG NIL)
(SETQ YESFNS USERWORDS)
(/SET (QUOTE PRETTYMACROS)
(UNION [QUOTE ((RECORD (L)
(PROP RECORD L)
(P (RECORD L)))
(LMMMAC (L)
(P (FIXMACRO (QUOTE L]
PRETTYMACROS))
(DEFINEQ
(COUNTDOWN
[LAMBDA (SEXP ALST)
(COND
((NULL ALST)
NIL)
((LISTP SEXP)
(COUNTDOWN (CDR SEXP)
(COUNTDOWN (CAR SEXP)
ALST)))
(T (PROG (X)
(SETQ X (ASSOC SEXP ALST))
(RETURN (COND
((NULL X)
ALST)
((EQP (CDR X)
1)
NIL)
(T (RPLACD X (SUB1 (CDR X)))
ALST])
(EXPANSION
[LAMBDA (FORM)
(PROG [(MACVAL (GETP (CAR FORM)
(QUOTE MACRO]
(COND
((NOT MACVAL)
FORM)
((MEMB (CAR MACVAL)
(QUOTE [LAMBDA NLAMBDA]))
(CONS MACVAL (CDR FORM)))
[(AND (CAR MACVAL)
(ATOM (CAR MACVAL)))
(EVALA (CADR MACVAL)
(LIST (CONS (CAR MACVAL)
(CDR FORM]
(T (SUBPAIR (CAR MACVAL)
(CDR FORM)
(CADR MACVAL])
)
(RPAQ RECORDFLG NIL)
[RPAQQ MACEXPAND (M MACEXPAND (IF (GETP (## 1)
'MACRO)
((I : (EXPANSION (##]
(EDITE MACEXPAND (QUOTE ((COMS (##))
OK)))
(DEFINEQ
(PRINTREC
[LAMBDA (REC VAL)
[COND
((NLISTP REC)
(SETQ REC (GETP REC (QUOTE RECORD]
(PRINTREC1 REC VAL)
NIL])
(PRINTREC1
[LAMBDA (REC VAL)
(COND
((NULL REC)
NIL)
((ATOM REC)
(PRIN1 REC)
(PRIN1 " = ")
(PRINT VAL))
(T (PRINTREC1 (CAR REC)
(CAR VAL))
(PRINTREC1 (CDR REC)
(CDR VAL])
(!RECORD
[LAMBDA (NAME FIELD)
(PROG (GS)
(SETQ GS (GENSYM))
(RECORD NAME (CONS GS FIELD))
(PUT GS (QUOTE RECDEFAULT)
NAME)
(MACRO (LIST (LIST (PACK (LIST NAME (QUOTE ?)))
(LIST (QUOTE LAMBDA)
(QUOTE (GS))
(LIST (QUOTE EQ)
(QUOTE (CAR GS))
(KWOTE NAME])
)
(/SET (QUOTE NOFNS)
(UNION (QUOTE (FOR IF))
NOFNS))
(/SET (QUOTE QUOTEFNS)
NIL)
(DEFINEQ
(FIXMACRO
[LAMBDA (FN)
(SELECTQ
(FNTYP FN)
[EXPR (/PUT FN (QUOTE MACRO)
(COPY (COND
((ANYTWICE FN (CADR (GETD FN))
(CADDR (GETD FN)))
(GETD FN))
(T (CDR (GETD FN]
[FEXPR
(AND
(EQ (CAAR (LAST (GETD FN)))
(QUOTE EVAL))
(/PUT FN (QUOTE MACRO)
(COPY (LIST (QUOTE L)
(CONS [CONS (QUOTE LAMBDA)
(CADRLAST (CDR (GETD FN]
(CARLIST (CADR (GETD FN))
(QUOTE L]
[EXPR* (OR (ANYTWICE FN NIL (CADDR (GETD FN)))
(/PUT FN (QUOTE MACRO)
(COPY (GETD FN]
[FEXPR*
(AND (EQ (CAAR (LAST (GETD FN)))
(QUOTE EVAL))
(/PUT FN (QUOTE MACRO)
(COPY (LIST (CADR (GETD FN))
(CONS (QUOTE PROGN)
(CADRLAST (CDDR (GETD FN]
(ERROR FN "FIXMACRO CAN'T"])
(MACRO
[LAMBDA (L)
(PROG ((MACROFLAG T))
(MAPC (DEFINE L)
(FUNCTION (LAMBDA (X)
(FIXMACRO X)
(COND
((NOT RECORDFLG)
(FILEADD LMMMAC X])
(ANYTWICE
[LAMBDA (FN ARGS SEXP)
(NOT (COUNTDOWN SEXP (CONS (CONS FN 1)
(MAPCAR ARGS (FUNCTION (LAMBDA (X)
(CONS X 2])
(CADRLAST
[LAMBDA (L)
(COND
((NULL (CDR L))
(LIST (CADAR L)))
(T (CONS (CAR L)
(CADRLAST (CDR L])
(CARLIST
[LAMBDA (L DEF)
(CONS (LIST (QUOTE CAR)
DEF)
(AND (CDR L)
(CARLIST (CDR L)
(LIST (QUOTE CDR)
DEF])
)
(DEFINEQ
(RECORD
[LAMBDA (NAME FIELD RECORDFLG)
(COND
(FIELD (/PUT NAME (QUOTE RECORD)
FIELD))
[(SETQ FIELD (GETP NAME (QUOTE RECORD]
(T (ERROR "EMPTY RECORD" NAME)))
(SETQ RECORDFLG T)
[MACRO (LIST (LIST NAME
(SUBST FIELD (QUOTE FIELD)
(QUOTE (NLAMBDA RECORDVAR
(SETQ RECORDVAR
(REMOVE (QUOTE IS)
(REMOVE (QUOTE =)
RECORDVAR)))
(EVAL (COMPOSE RECORDVAR
(QUOTE FIELD]
(RECDO FIELD (QUOTE X))
(AND (GETD (QUOTE FILEADD))
[NOT (MEMB (CAR (QUOTE CURRENTFILE))
(QUOTE (NOBIND NIL]
(FILEADD RECORD NAME))
(SETQ RECORDFLG NIL)
NAME])
(RECDO
[LAMBDA (FORMAT DEF)
(COND
((NULL FORMAT)
NIL)
((LISTP FORMAT)
(RECDO (CAR FORMAT)
(LIST (QUOTE CAR)
DEF))
(RECDO (CDR FORMAT)
(LIST (QUOTE CDR)
DEF)))
(T
(MACRO
(LIST
(LIST FORMAT
(SUBST DEF (QUOTE DEF)
(QUOTE (NLAMBDA L
(SETQ L (REMOVE (QUOTE OF)
L))
(EVAL (SUBST (COND
((NULL (CDR L))
(CAR L))
(T L))
'X
(QUOTE DEF])
(COMPOSE
[LAMBDA (L FIELD)
(SELECTQ (CAR L)
[FROM (COND
((ATOM (CADR L))
(COMPOSE1 L FIELD (CADR L)))
(T (LIST (LIST (QUOTE LAMBDA)
(QUOTE (COMPOSEVAR))
(COMPOSE1 L FIELD (QUOTE COMPOSEVAR)
))
(CADR L]
[DFROM (COND
[(ATOM (CADR L))
(COND
((EQ [CADR (SETQ FIELD (COMPOSE1
L FIELD (CADR L]
(CADR L))
FIELD)
(T (LIST (QUOTE PROGN)
FIELD
(CADR L]
(T (LIST (LIST (QUOTE LAMBDA)
(QUOTE (COMPOSEVAR))
(COMPOSE1 L FIELD (QUOTE
COMPOSEVAR))
(QUOTE COMPOSEVAR))
(CADR L]
(COMPOSE1 L FIELD (QUOTE COMPOSEVAR])
(COMPOSE1
[LAMBDA (L FIELD DEF)
(PROG (K)
(COND
((SETQ K (COMPOSE2 L FIELD DEF))
(CAR K))
(T (COMPOSE3 L FIELD DEF])
(COMPOSE2
[LAMBDA (L FIELD DEF)
(COND
((NULL FIELD)
NIL)
[(ATOM FIELD)
(AND (MEMB FIELD L)
(SELECTQ (CAR L)
[DFROM (LIST (LIST (SELECTQ (CAR DEF)
(CAR (QUOTE RPLACA))
(QUOTE RPLACD))
(CADR DEF)
(SUBST DEF (QUOTE **)
(GET L FIELD]
(LIST (SUBST DEF (QUOTE **)
(GET L FIELD]
(T
(PROG (KA KD)
(SETQ KD (COMPOSE2 L (CDR FIELD)
(LIST (QUOTE CDR)
DEF)))
(SETQ KA (COMPOSE2 L (CAR FIELD)
(LIST (QUOTE CAR)
DEF)))
(AND (NULL KA)
(NULL KD)
(RETURN NIL))
(RETURN
(LIST
(SELECTQ (CAR L)
(DFROM (≠REPLACE (CAR KA)
(CAR KD)))
(≠CONS [COND
(KA (CAR KA))
(T (COMPOSE1 L (CAR FIELD)
(LIST (QUOTE CAR)
DEF]
(COND
(KD (CAR KD))
(T (COMPOSE1 L (CDR FIELD)
(LIST (QUOTE CDR)
DEF])
(COMPOSE3
[LAMBDA (L FIELD DEF)
(SELECTQ (CAR L)
(FROM DEF)
(COMPOSE4 FIELD])
(COMPOSE4
[LAMBDA (FIELD)
(COND
((NULL FIELD)
NIL)
[(ATOM FIELD)
([LAMBDA (X)
(COND
(X (KWOTE X]
(GETP FIELD (QUOTE RECDEFAULT]
(T (≠CONS (COMPOSE4 (CAR FIELD))
(COMPOSE4 (CDR FIELD])
(≠CONS
[LAMBDA (CARPART CDRPART)
(COND
[(OR (EQ (CAR CDRPART)
(QUOTE LIST))
(NOT (CAR CDRPART)))
(CONS (QUOTE LIST)
(CONS CARPART (CDR CDRPART]
(T (LIST (QUOTE CONS)
CARPART CDRPART])
(≠REPLACE
[LAMBDA (CARPART CDRPART)
(COND
((NULL CARPART)
CDRPART)
((NULL CDRPART)
CARPART)
((AND (EQ (CAR CARPART)
(QUOTE RPLACA))
(EQ (CAR CDRPART)
(QUOTE RPLACD))
(EQUAL (CADR CARPART)
(CADR CDRPART)))
(LIST (QUOTE RPLACD)
CARPART
(CADDR CDRPART)))
(T (LIST (QUOTE PROGN)
CARPART CDRPART])
)
(DEFINEQ
(*FOR
[LAMBDA (L)
(PROG (N FV PV EPILOGUE PROLOGUE DOFORM DOTYPE VAR RANGE LST
VARNEXT NEXT NEXTS N2 N3 INIT TESTSET)
(SETQ N 1)
FORLOOP
[AND (EQ (CAR L)
(QUOTE NEW))
(+PV (CAR (SETQ L (CDR L]
(SETQ VAR (CAR L))
(SETQ RANGE (CADDR L))
(+NEXT (SETQ VARNEXT (VARNAME "NEXT")))
(SELECTQ
(CADR L)
[IN (+TESTSET (CONDIT (NEGATE (INITL (+PV (SETQ LST
(VARNAME "LIST")
))
RANGE))
(GONEXTN)))
(+TESTSET (SETIT VAR (LIST (QUOTE CAR)
LST)))
(+NEXT (SETIT LST (LIST (QUOTE CDR)
LST]
[ON (+TESTSET (CONDIT (NEGATE VAR)
(GONEXTN)))
(+NEXT (SETIT (INITL VAR RANGE)
(LIST (QUOTE CDR)
VAR]
[:=
[SETQ N2 (COND
((ATOM (CADR RANGE))
(CADR RANGE))
(T (INITL (+PV (VARNAME "MAX"))
(CADR RANGE]
(SETQ N3 (COND
[(CDDR RANGE)
(COND
((ATOM (CADDR RANGE))
(CADDR RANGE))
(T (INITL (+PV (VARNAME "INC"))
(CADDR RANGE]
((AND (NUMBERP (CAR RANGE))
(NUMBERP (CADR RANGE))
(GREATERP (CAR RANGE)
(CADR RANGE)))
-1)
(T 1)))
(INITL VAR (CAR RANGE))
(+TESTSET
(CONDIT
(COND
[(NOT (NUMBERP N3))
(LIST (QUOTE COND)
(LIST (LIST (QUOTE MINUSP)
N3)
(LIST (QUOTE ILESSP)
VAR N2))
(LIST T (LIST (QUOTE OR
(LIST (QUOTE ZEROP)
N3)
(LIST (QUOTE GREATERP)
VAR N2]
((MINUSP N3)
(LIST (QUOTE ILESSP)
VAR N2))
(T (LIST (QUOTE IGREATERP)
VAR N2)))
(GONEXTN)))
(+NEXT (SETIT VAR (LIST (QUOTE IPLUS)
VAR N3]
(IS (+TESTSET (SETIT VAR RANGE)))
(ERROR "INVALID FOR TYPE"))
(SETQ L (CDDDR L))
ASLOOP
(SELECTQ (CAR L)
(AS (SETQ L (CDR L))
(SETQ NEXTS (APPEND NEXTS NEXT))
(SETQ NEXT)
(GO FORLOOP))
((IF WHEN)
(+TESTSET (CONDIT (NEGATE (CADR L))
(LIST (QUOTE GO)
VARNEXT)))
(SETQ L (CDDR L)))
(UNTIL (+NEXT (CONDIT (CADR L)
(GONEXTN)))
(SETQ L (CDDR L)))
(WHILE (+TESTSET (CONDIT (NEGATE (CADR L))
(GONEXTN)))
(SETQ L (CDDR L)))
(GO FORTEST))
(GO ASLOOP)
FORTEST
(SETQ PROLOGUE (APPEND TESTSET (LIST (| "LOOP" N))
INIT PROLOGUE))
[SETQ EPILOGUE (CONS (| "NEXT" N)
(APPEND (REVERSE NEXT)
(REVERSE NEXTS)
(CONS (LIST (QUOTE GO)
(| "LOOP" N))
EPILOGUE]
[SETQ TESTSET (SETQ INIT (SETQ NEXT (SETQ NEXTS]
(COND
((EQ (CAR L)
(QUOTE FOR))
(SETQ L (CDR L))
(SETQ N (ADD1 N))
(GO FORLOOP)))
(SETQ DOTYPE (CAR L))
(SETQ DOVAL (CAR (LAST L)))
(+PV (QUOTE FOR-VALUE))
(SETQ FV (SELECTQ DOTYPE
((APPEND LIST NCONC)
(QUOTE (CAR FOR-VALUE)))
(QUOTE FOR-VALUE)))
[SETQ DOFORM
(SELECTQ
DOTYPE
[(AND OR)
(CONDIT (LIST (SELECTQ DOTYPE
(AND (INITL (QUOTE FOR-VALUE)
T)
(QUOTE NOT))
(QUOTE PROGN))
(SETIT (QUOTE FOR-VALUE)
DOVAL))
(QUOTE (RETURN FOR-VALUE]
(PROG2 (SETIT (QUOTE FOR-VALUE)
DOVAL))
(DO DOVAL)
(SETIT (QUOTE FOR-VALUE)
(CONS (OR [CDR (ASSOC DOTYPE
(QUOTE ((LIST . TCONC)
(NCONC . LCONC)
(XLIST . CONS)
(APPEND . LCONC]
DOTYPE)
(SELECTQ DOTYPE
((LIST NCONC)
(LIST (QUOTE FOR-VALUE)
DOVAL))
(APPEND (LIST 'FOR-VALUE
(LIST 'APPEND DOVAL)))
(LIST DOVAL (QUOTE FOR-VALUE]
[COND
((EQ (CAR (SETQ L (CDR L)))
(QUOTE FIRST))
(INITL (QUOTE FOR-VALUE)
(SELECTQ
DOTYPE
[(LIST APPEND NCONC)
(COND
((NLISTP (CADR L))
(LIST [QUOTE (LAMBDA (FOR% INIT)
(CONS FOR% INIT
(LAST FOR% INIT]
(CADR L)))
(T (CONS (CADR L)
(LAST (CADR L]
(CADR L)))
(SETQ L (CDDR L)))
((MEMB DOTYPE (QUOTE (PLUS IPLUS TIMES ITIMES MAX MIN)))
(INITL (QUOTE FOR-VALUE)
(CDR (ASSOC DOTYPE (QUOTE ((PLUS . 0)
(IPLUS . 0)
(TIMES . 1)
(ITIMES . 1]
(RETURN (CONS (QUOTE PROG)
(CONS PV (APPEND INIT (REVERSE PROLOGUE)
(REVERSE (CDR (REVERSE L)))
(LIST DOFORM)
EPILOGUE
(LIST (QUOTE RETURN)
(LIST (QUOTE RETURN)
FV])
(+NEXT
[LAMBDA (ITEM)
(SETQ NEXT (CONS ITEM NEXT))
ITEM])
(VARNAME
[LAMBDA (STR)
(PACK (LIST STR "*" VAR])
(CONDIT
[LAMBDA (PRD DO)
(LIST (QUOTE COND)
(LIST PRD DO])
(SETIT
[LAMBDA (VAR VAL)
(AND (NOT (EQ VAR VAL))
(LIST (QUOTE SETQ)
VAR VAL])
(INITL
[LAMBDA (VAR VAL)
(SETQ INIT (CONS (SETIT VAR VAL)
INIT))
VAR])
(+PV
[LAMBDA (VAR)
(SETQ PV (CONS VAR PV))
VAR])
(GONEXTN
[LAMBDA NIL
(LIST (QUOTE GO)
(COND
((EQP N 1)
(QUOTE RETURN))
(T (PACK (LIST "NEXT*" (SUB1 N])
(|
[LAMBDA (STR VAL)
(PACK (LIST STR "*" N])
(+TESTSET
[LAMBDA (ITEM)
(SETQ TESTSET (CONS ITEM TESTSET))
ITEM])
(NEGATE
[LAMBDA (EXP)
(SELECTQ (CAR EXP)
((NOT NULL)
(CADR EXP))
(LIST (QUOTE NOT)
EXP])
(*IF
[LAMBDA (L)
(AND L (CONS [CONS (CAR L)
(COND
((NOT (EQ (CADR L)
(QUOTE THEN)))
(ERROR L "NO CORRESPONDING THEN IN IF"))
(T (SETQ L (CDDR L))
(THENCLAUSE]
(COND
((NULL L)
NIL)
((EQ (CAR L)
(QUOTE ELSEIF))
(*IF (CDR L)))
((EQ (CAR (SETQ L (CDR L)))
(QUOTE IF))
(*IF (CDR L)))
(T (LIST (CONS T (THENCLAUSE])
(THENCLAUSE
[LAMBDA NIL
(COND
([OR (NULL L)
(MEMB (CAR L)
(QUOTE (ELSE ELSEIF]
(LIST NIL))
[[OR (NOT (CDR L))
(MEMB (CADR L)
(QUOTE (ELSE ELSEIF]
(PROG1 (LIST (CAR L))
(SETQ L (CDR L]
(T (CONS (CAR L)
(PROGN (SETQ L (CDR L))
(THENCLAUSE])
(FOR
[NLAMBDA FOR-EXPRESSION
(EVAL (*FOR FOR-EXPRESSION])
(IF
[NLAMBDA IF-EXPRESSION
(EVAL (CONS (QUOTE COND)
(*IF IF-EXPRESSION])
)
(FIXMACRO (QUOTE IF))
(FIXMACRO (QUOTE FOR))
STOP